Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume2/pstrings/part01

Internet Message Format | 1991-08-07 | 33.3 KB

From: [e-mail] (Ian Cottam)
Newsgroups: comp.sources.misc
Subject: v02i075: Unbounded Strings Package in ISO level 1 Pascal
Message-ID: <[e-mail]>
Date: 15 Mar 88 10:37:01 GMT
Approved: [e-mail]

comp.sources.misc: Volume 2, Issue 75
Submitted-By: "Ian Cottam" <[e-mail]>
Archive-Name: pstrings/part01

#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    README
#    strings.h
#    CtoS.p
#    assignS.p
#    compare.p
#    concatS.p
#    disposeS.p
#    emptyS.p
#    eqS.p
#    finalS.p
#    first.p
#    geS.p
#    getsubS.p
#    gtS.p
#    indexS.p
#    initS.p
#    initvalparamS.p
#    leS.p
#    lengthS.p
#    ltS.p
#    matchS.p
#    mk.p
#    mkS.p
#    mkStaticS.p
#    neS.p
#    newS.p
#    next.p
#    readS.p
#    readtS.p
#    repS.p
#    updateS.p
#    writeS.p
#    writelnS.p
#    Makefile
# This archive created: Tue Mar 15 10:11:49 1988
export PATH; PATH=/bin:$PATH
if test -f 'README'
then
    echo shar: will not over-write existing file "'README'"
else
cat << \SHAR_EOF > 'README'

This is an Unbounded-length Strings package I wrote for our
first year undergrads to use some years ago.  It is written in
and assumes you are using an ISO level 1 conforming Pascal
compiler. (If they come pretty close e.g. SUN Pascal then you
will be alright.  N.B. Berkeley pc is NOT close enough -- at least
the version I have which is that with 4.3BSD.)

I have used the package with: SUN Pascal, VAX-VMS-Pascal, and York Pascal
(a UN*X/portable Pascal compiler) on VAX-UN*X.

See the strings.h header file for some implementation comments.

Where you put things like #include is, of course, compiler specific.
The distributed version should work on SUNs; other systems will require
you to make trivial (hopefully) mods.  Even on SUNs you may have trouble
with erroneous complaints from /usr/lib/pc3 -- the separate compilation
checker -- about redefinitions.  Personally, I don't bother with
/usr/lib/pc3.

Good luck
-Ian Cottam
Univ of Manchester, Dept of Comp Sci, Oxford Rd, Manchester
M13 9PL, UK, [e-mail]

SHAR_EOF
fi # end of overwriting check
if test -f 'strings.h'
then
    echo shar: will not over-write existing file "'strings.h'"
else
cat << \SHAR_EOF > 'strings.h'
{
*
* String handling package in Pascal (ISO Level 1).
*
*   This package of procedures and functions implements unbounded
* Strings of Characters.
*
* N.B. All string variables MUST be initialised via initS(s).
*      Assignment MUST be via assignS(dest, src).
*      If desired, storage may be reclaimed via finalS(s).
*  i.e.
*         var s,t: String;
*             . . .
*       initS(s); initS(t);
*          . . .
*       assignS(t, concatS(mkS('Join this string '), mkS('to this')));
*       assignS(s, t);
*          . . .
*       finalS(s); finalS(t);
*
* Additionally, string by-value parameters must be initialised by calling
* initvalparamS(s).
* * e.g.
*
*    procedure p(s:String);
*     begin writelnS(output, concatS(s, concatS(s,s)))
*     end;
*
* MUST be written as:
*
*    procedure p(s:String);
*     begin initvalparamS(s);
*           writelnS(output, concatS(s, concatS(s,s)))
*     end;
* (This is because the package performs incremental garbage collection
*  on unassigned strings, but extant by-value references cannot be
*  detected.)
*
*
*
* Implementation Issues:
*
* The representation is a header record containing a
* length field, a reference count, and a packed array [1..slength]
* of Char, followed by zero or more `tail' chunks - also
* containing a packed array [1..slength] of Char.
* The empty string is represented by nil.  Beware of
* s1 := s2   this copies pointers (!) not the strings themselves.
* `:=' between strings should not be used; it cannot be banned
* because types inherit assignment in Pascal.
* The procedure     assignS(dest, source)
* should be used to copy strings, it uses the reference count to
* avoid copying.  Only if updateS is used will the string
* actually be copied (if the ref count is > 1).
*
*   All the routines end with a capital S.
*
* Ian Cottam, University of Manchester,  NOV.85. revised MAR.86 and DEC.86.
*                                        revised MAR.88 - better names,
*                     plus use of initvalparamS.
}

{ -- string chunk length - any length > 0 will work }
const slength = 16;

type

  String = ^ stringrec;


  Nat0 = 0 .. maxint;

  Nat1 = 1 .. maxint;


  stringtail = ^ tailrec;

  stringrec = record
    LEN:  Nat1; { -- Note: no 0 as nil represents '' }
    REFS: Nat0; { -- How many refs are there to this string }
                { -- N.B. only = 0 when string generated by a function }
    HEAD: packed array [1..slength] of Char;
    TAIL: stringtail
      end;

  tailrec   = record
        MORE: packed array [1..slength] of Char;
        REST: stringtail
          end;


 { -- Result of compare - internal function to ADT }
 StrCmpResult = (lt, eq, gt);

 { -- type for sequencing thru strings - internal to ADT at the moment}
 CharOfString = record
                   POS: 1..slength;
                  case KIND: Boolean of
             true:  (HD: String);
             false: (TL: stringtail)
                end;


{************ function and procedure headings **************}

{ --   ...   in Alphabetical order   ...           }



procedure assignS(var lhs: String; rhs: String);
{
* lhs := rhs
}
external;



{ ***** AUXILIARY FUNCTION ***** }
function compare(left, right:String):StrCmpResult;
{
* String comparison - used in the impl. of eqS, neS, ltS, etc.
}
external;


function concatS(s1, s2: String):String;
{
* Returns s1 + s2
* Concatenates s1 and s2.
}
external;



function CtoS(c: Char):String;
{
* Converts a character into a string of length 1
}
external;



procedure disposeS(var s: String);
{
* reclaims the storage associated with the string s
}
external;



function emptyS: String;
{
* Returns the empty or null string ''
}
external;



function eqS(left,right: String):Boolean;
{
* left = right
}
external;


procedure finalS(var s: String);
{
* same as disposeS but possibly better name
* reclaims the storage associated with the string s
}
external;



{ ***** AUXILIARY FUNCTION ***** }
procedure first(var c:CharOfString; var s: String);
{
* c initialised to point to the first char of s
*
* precondition
*     s <> ''
}
external;



function geS(left,right: String):Boolean;
{
* left >= right
}
external;



function getsubS(s: String; frompos, topos: Nat0):String;
{
* Returns s[frompos..topos]
* Extracts a substring of s.
*  returns ''  if frompos..topos not in range.
}
external;



function gtS(left,right: String):Boolean;
{
* left > right
}
external;



function indexS(s: String; i: Nat1):Char;
{
* Returns s[i]
*
* precondition:
*     i <= lengthS(s)
}
external;



procedure initS(var s: String);
{
* Initialises s to be the empty or null string ''
* Same as newS, but possibly less confusing name.
}
external;



procedure initvalparamS(var s: String);
{
* Initialises s, which should be a value parameter, to be
* safely useable within the current procedure.
}
external;



function leS(left,right: String):Boolean;
{
* left <= right
}
external;



function lengthS(s: String):Nat0;
{
* Returns the dynamic length of a string
}
external;



function ltS(left,right: String):Boolean;
{
* left < right
}
external;



function matchS(s, pat: String):Nat0;
{
* Returns position of pat in s or 0 if not present.
* Empty strings are not considered present!
}
external;



{ ***** AUXILIARY FUNCTION ***** }
function mk(var static: packed array [lo..hi:Integer] of Char;
            limit: Integer):String;
{
* Converts a static Pascal string into a (dynamic) String.
* From lo to limit rather than hi.
* This internal procedure may be made generally available
* should there be a demand.
}
external;


function mkS(static: packed array [lo..hi:Integer] of Char):String;
{
* Converts a static Pascal string into a (dynamic) String.
}
external;



procedure mkStaticS(s: String; var p: packed array[lo..hi:Integer] of Char);
{
* Converts a dynamic string into a static string.
* p is null padded if necessary.
* Info will be lost if lengthS(s) > hi-lo+1.
}
external;



function neS(left,right: String):Boolean;
{
* left <> right
}
external;



procedure newS(var s: String);
{
* Initialises s to be the empty or null string ''
}
external;



{ ***** AUXILIARY FUNCTION ***** }
procedure next(var c: CharOfString; var ch: Char);
{
* c is advanced to point to next char in its string and current char
* returned in ch
*
* precondition
*     c initialised by call to first and not at end of string
}
external;



procedure readS(var f: Text; var s: String);
{
* Reads a string from text file f; eoln terminating.  The input is
* left pointing to the beginning of the next line, if any.
*
* precondition:
*    f open for reading & not eof(f)
}
external;




procedure readtS(var f: Text; var s: String; function stop(c:Char):Boolean);
{
* Reads a string from text file f; eoln or stop(c) returning true
* (whichever occurs first) terminating.  In either case,
* input is left positioned at the terminator.
*
* precondition:
*    f open for reading & not eof(f)
}
external;



function repS(s: String; n: Nat0):String;
{
* Returns s * n
* Replicates s, n times.
}
external;



procedure updateS(var s: String; i: Nat1; c:Char);
{
* Updates the string s at position  i  with the char c.
* if i > lengthS(s), s is first space filled upto i-1.
}
external;



procedure writeS(var f: Text; s: String);
{
* Write the dynamic string s to file f
*
* precondition:
*    f open for writing
}
external;



procedure writelnS(var f: Text; s: String);
{
* Write the dynamic string s to file f followed by an eoln marker
*
* precondition:
*    f open for writing
}
external;
SHAR_EOF
fi # end of overwriting check
if test -f 'CtoS.p'
then
    echo shar: will not over-write existing file "'CtoS.p'"
else
cat << \SHAR_EOF > 'CtoS.p'




# include "strings.h"

function CtoS{(c: Char):String};
{
* Converts a character into a string of length 1
}
   var ss: packed array [1 .. 1] of Char;
begin
    ss[1] := c;
    CtoS  := mkS(ss)
end{ -- CtoS};
SHAR_EOF
fi # end of overwriting check
if test -f 'assignS.p'
then
    echo shar: will not over-write existing file "'assignS.p'"
else
cat << \SHAR_EOF > 'assignS.p'




# include "strings.h"

procedure assignS{(var lhs: String; rhs: String)};
{
* lhs := rhs
}
begin
     if lhs <> rhs then begin { -- Care with case, e.g., assignS(x,x) }
         disposeS(lhs);
         if rhs = nil then { -- Empty string } lhs := nil
         else begin
        lhs := rhs;    { -- Ref. copy }
        with rhs^ do REFS := REFS+1
         end
     end
end{ -- assignS};
SHAR_EOF
fi # end of overwriting check
if test -f 'compare.p'
then
    echo shar: will not over-write existing file "'compare.p'"
else
cat << \SHAR_EOF > 'compare.p'




# include "strings.h"

function compare{(left, right: String):StrCmpResult};
   var lenl, lenr: Nat0;  ltail, rtail: stringtail;
       state: (GoOn, Less, Greater, Stop);
begin
  lenl  := lengthS(left); lenr  := lengthS(right);
  { -- Do trivial cases first }
  if lenl = 0 then
    if lenr = 0 then compare := eq else compare := lt
  else    if lenr = 0 then compare := gt else begin
   { -- Non-trivial cases - both left and right are non empty }
   ltail := left^.TAIL;    rtail := right^.TAIL;
   if left^.HEAD < right^.HEAD then state := Less else
   if left^.HEAD > right^.HEAD then state := Greater else
   if (ltail = nil) or (rtail = nil)
   then state := Stop
   else state := GoOn;
   { -- Check tails if necessary }
   while state = GoOn do
    if ltail^.MORE < rtail^.MORE then state := Less else
    if ltail^.MORE > rtail^.MORE then state := Greater else
    if (ltail^.REST = nil) or (rtail^.REST = nil)
    then state := Stop
    else
     begin ltail := ltail^.REST; rtail := rtail^.REST end;
   { -- Final check for differing lengths (etc.) }
   case state of
    Less:     compare := lt;
    Greater: compare := gt;
    Stop:     if lenl < lenr then compare := lt else
         if lenl > lenr then compare := gt
         else compare := eq
   end
  end;
  { -- comparison may have involved constant strings }
  if left  <> nil then if  left^.REFS = 0 then disposeS(left);
  if right <> nil then if right^.REFS = 0 then disposeS(right)
end{ -- compare};
SHAR_EOF
fi # end of overwriting check
if test -f 'concatS.p'
then
    echo shar: will not over-write existing file "'concatS.p'"
else
cat << \SHAR_EOF > 'concatS.p'




# include "strings.h"

function concatS{(s1, s2: String):String};
{
* Returns s1 + s2
* Concatenates s1 and s2.
}
   var t: String;  { -- Result is built in t }
       l, r, End1: stringtail;
       StillInHeadOfT, InTailOfT, InTailOfS2: Boolean;
       i, j: Nat1;
       tindx, rindx: 1..slength;
       null: Char;
begin
 t := nil;
 null := chr(0);
 { -- Deal with trivial cases first }
 if s1 = nil then concatS := s2 else
 if s2 = nil then concatS := s1 else
 { -- Both s1 and s2 are non-empty }
  begin
    new(t);
    with t^ do begin
      LEN := s1^.LEN + s2^.LEN;
      { -- Copy head of s1 }
      HEAD := s1^.HEAD;
      TAIL := nil;
          { -- Allocate and link in any extra string chunks needed }
        for i := 1 to (LEN-1) div slength do begin
            new(l);
        { -- pad with nulls if chunk is last one }
        if i=1 then
         for j:=1 to slength do l^.MORE[j] := null;
            l^.REST := TAIL;
            TAIL := l
      end;
          { -- Loop through copying string tail of s1, if required }
      l := TAIL;  End1 := TAIL; r := s1^.TAIL;
      for i := 1 to (s1^.LEN-1) div slength  do begin
           l^.MORE := r^.MORE;
        End1 := l;
           l := l^.REST;
           r := r^.REST
         end;
      { -- End1 points to the last tail entry (partially) filled}
      if s1^.LEN mod slength <> 0 then l := End1;
      r := s2^.TAIL;
      { -- Loop thru copying s2 to end of t char by char! }
      tindx := s1^.LEN mod slength + 1;
      rindx := 1;
      StillInHeadOfT := s1^.LEN < slength;
      InTailOfT := false;  InTailOfS2 := false;
      for i := 1 to s2^.LEN do begin
        if  StillInHeadOfT then begin
             HEAD[tindx] := s2^.HEAD[rindx];
             StillInHeadOfT := tindx < slength
        end
        else
        if i <= slength then begin
            InTailOfT := true;
            l^.MORE[tindx] := s2^.HEAD[rindx]
        end
        else begin
            InTailOfS2 := true;
            l^.MORE[tindx] := r^.MORE[rindx]
        end;
        { -- Always inc indices and step down lists if req. }
        tindx := tindx mod slength + 1;
        if (tindx = 1) and InTailOfT  then l := l^.REST;
        rindx := rindx mod slength + 1;
        if (rindx = 1) and InTailOfS2 then r := r^.REST
      end
      end{ -- with};
    { -- Make 0 ref count }
    t^.REFS := 0;
    { -- Tidy up any intermediate storage }
    if s1 <> nil then if s1^.REFS = 0 then disposeS(s1);
    if s2 <> nil then if s2^.REFS = 0 then disposeS(s2);
    concatS := t
 end
end{ -- concatS};
SHAR_EOF
fi # end of overwriting check
if test -f 'disposeS.p'
then
    echo shar: will not over-write existing file "'disposeS.p'"
else
cat << \SHAR_EOF > 'disposeS.p'




# include "strings.h"

procedure disposeS{(var s: String)};
{
* reclaims the storage associated with the string s
}
   var t, next: stringtail;
begin
  if s = nil then { -- Do nothing } else
     if s^.REFS < 2 then begin { -- Only ref. to this string }
    t := s^.TAIL;
    dispose(s); s := nil; { -- emptyS }
    while t <> nil do begin
        next := t^.REST;
        dispose(t);
        t := next
    end
     end
     else begin
    { -- Decrement the references count, and make s = the empty string }
    with s^ do REFS := REFS-1;
    s := nil
     end
end{ -- disposeS};
SHAR_EOF
fi # end of overwriting check
if test -f 'emptyS.p'
then
    echo shar: will not over-write existing file "'emptyS.p'"
else
cat << \SHAR_EOF > 'emptyS.p'




# include "strings.h"

function emptyS{: String};
{
* Returns the empty or null string ''
}
begin
    emptyS := nil
end{ -- emptyS};
SHAR_EOF
fi # end of overwriting check
if test -f 'eqS.p'
then
    echo shar: will not over-write existing file "'eqS.p'"
else
cat << \SHAR_EOF > 'eqS.p'




# include "strings.h"

function eqS{(left,right: String):Boolean};
{
* left = right
}
begin
    eqS := compare(left, right) = eq
end{ -- eqS};
SHAR_EOF
fi # end of overwriting check
if test -f 'finalS.p'
then
    echo shar: will not over-write existing file "'finalS.p'"
else
cat << \SHAR_EOF > 'finalS.p'




# include "strings.h"

procedure finalS{(var s: String)};
{
* reclaims the storage associated with the string s
}
begin
    disposeS(s)
end{ -- finalS};
SHAR_EOF
fi # end of overwriting check
if test -f 'first.p'
then
    echo shar: will not over-write existing file "'first.p'"
else
cat << \SHAR_EOF > 'first.p'




# include "strings.h"

procedure first{(var c:CharOfString; var s: String)};
{
* c initialised to point to the first char of s
*
* precondition
*     s <> ''
}
begin
    with c do begin
        KIND := true; { -- head record }
          HD := s;
         POS := 1
    end
end{ -- first};
SHAR_EOF
fi # end of overwriting check
if test -f 'geS.p'
then
    echo shar: will not over-write existing file "'geS.p'"
else
cat << \SHAR_EOF > 'geS.p'




# include "strings.h"

function geS{(left,right: String):Boolean};
{
* left >= right
}
begin
    geS := compare(left, right) <> lt
end{ -- geS};
SHAR_EOF
fi # end of overwriting check
if test -f 'getsubS.p'
then
    echo shar: will not over-write existing file "'getsubS.p'"
else
cat << \SHAR_EOF > 'getsubS.p'




# include "strings.h"


function getsubS{(s: String; frompos, topos: Nat0):String};
{
* Returns s[frompos..topos]
* Extracts a substring of s.
*  returns ''  if frompos..topos not in range.
}
   const BufferLength = 512;
   var t: String; j,i, stoppos: Nat1; ch: Char; sp: CharOfString;
       buf: packed array [1..BufferLength] of Char;
begin
    t := nil; { -- empty string }
    if topos <= lengthS(s) then begin
       { --  convert max(BufferLength) chars to fixed string }
       if topos-frompos+1 > BufferLength then
        stoppos := frompos+BufferLength-1
       else
        stoppos := topos;
       j := 1;
       first(sp, s);
       for i := 1 to frompos-1 do next(sp, ch);
       for i := frompos to stoppos do begin
        next(sp, ch);
        buf[j] := ch;
        j := j+1
       end{ -- for};
       { --  convert to String }
       if j <> 1 then { --  positive slice }
           t := mk(buf, j-1);
       { --  check any more left }
       if topos <> stoppos then
        t := concatS(t,  getsubS(s, stoppos+1, topos))
    end;
    if s <> nil then if s^.REFS = 0 then disposeS(s);
    getsubS := t
end{ -- getsubS};
SHAR_EOF
fi # end of overwriting check
if test -f 'gtS.p'
then
    echo shar: will not over-write existing file "'gtS.p'"
else
cat << \SHAR_EOF > 'gtS.p'




# include "strings.h"

function gtS{(left,right: String):Boolean};
{
* left > right
}
begin
    gtS := compare(left, right) = gt
end{ -- gtS};
SHAR_EOF
fi # end of overwriting check
if test -f 'indexS.p'
then
    echo shar: will not over-write existing file "'indexS.p'"
else
cat << \SHAR_EOF > 'indexS.p'




# include "strings.h"

function indexS{(s: String; i: Nat1):Char};
{
* Returns s[i]
*
* precondition:
*     i <= lengthS(s)
}
   var j: 2..maxint;  chunk: stringtail;
begin
  with s^ do
  if i <= slength then indexS := HEAD[i]
  else begin
    chunk := TAIL;
    for j := 2 to (i-1) div slength do chunk := chunk^.REST;
    indexS := chunk^.MORE[ (i-1) mod slength + 1 ]
  end
end{ -- indexS};
SHAR_EOF
fi # end of overwriting check
if test -f 'initS.p'
then
    echo shar: will not over-write existing file "'initS.p'"
else
cat << \SHAR_EOF > 'initS.p'




# include "strings.h"

procedure initS{(var s: String)};
{
* Initialises s to be the empty or null string ''
* This is a copy of newS for those people that prefer the name initS!
}
begin
    s := nil
end{ -- initS};
SHAR_EOF
fi # end of overwriting check
if test -f 'initvalparamS.p'
then
    echo shar: will not over-write existing file "'initvalparamS.p'"
else
cat << \SHAR_EOF > 'initvalparamS.p'




# include "strings.h"

procedure initvalparamS{(var s: String)};
{
* Initialises s, which should be a value parameter, to be
* safely useable within the current procedure.
*
* increase ref count for a by-value param
}
begin
    s^.REFS := s^.REFS + 1
end{ -- initvalparamS};
SHAR_EOF
fi # end of overwriting check
if test -f 'leS.p'
then
    echo shar: will not over-write existing file "'leS.p'"
else
cat << \SHAR_EOF > 'leS.p'




# include "strings.h"

function leS{(left,right: String):Boolean};
{
* left <= right
}
begin
    leS := compare(left, right) <> gt
end{ -- leS};
SHAR_EOF
fi # end of overwriting check
if test -f 'lengthS.p'
then
    echo shar: will not over-write existing file "'lengthS.p'"
else
cat << \SHAR_EOF > 'lengthS.p'




# include "strings.h"

function lengthS{(s: String):Nat0};
{
* Returns the dynamic length of a string
}
begin
    if s = nil then lengthS := 0 else lengthS := s^.LEN
end{ -- lengthS};
SHAR_EOF
fi # end of overwriting check
if test -f 'ltS.p'
then
    echo shar: will not over-write existing file "'ltS.p'"
else
cat << \SHAR_EOF > 'ltS.p'




# include "strings.h"

function ltS{(left,right: String):Boolean};
{
* left < right
}
begin
    ltS := compare(left, right) = lt
end{ -- ltS};
SHAR_EOF
fi # end of overwriting check
if test -f 'matchS.p'
then
    echo shar: will not over-write existing file "'matchS.p'"
else
cat << \SHAR_EOF > 'matchS.p'




# include "strings.h"

function matchS{(s, pat: String):Nat0};
{
* Returns position of pat in s or 0 if not present.
* Empty strings are not considered present!
}
  var diff, lens, lenp, start, next: Nat0;  nomatch: Boolean;
begin
  lens := lengthS(s);  lenp := lengthS(pat);
  if (lens = 0) or (lenp = 0) or (lenp > lens) then
    matchS := 0
  else begin
    start := 0;
    diff := lens - lenp;
    repeat
        start := start+1;
        next := 0;
        repeat
               next := next+1;
               nomatch := indexS(pat, next) <> indexS(s, start+next-1)
                until nomatch or (next = lenp);
    until not nomatch or (start > diff);
    if nomatch then matchS := 0 else matchS := start
  end;
  { -- possible that function called with constant string for pat }
  if pat <> nil then if pat^.REFS = 0 then disposeS(pat)
end{ -- matchS};
SHAR_EOF
fi # end of overwriting check
if test -f 'mk.p'
then
    echo shar: will not over-write existing file "'mk.p'"
else
cat << \SHAR_EOF > 'mk.p'




# include "strings.h"


function mk{(var static: packed array [lo..hi:Integer] of Char; limit: Integer):String};
{
* Converts a static Pascal string into a (dynamic) String.
* From lo to limit rather than hi.
* This internal procedure may be made generally available
* should there be a demand.
}
   var null: Char;
       StaticLength: Nat1;
       i, ExtraChunks, CurrentLength: Nat0;
       StringHead: String;
       temp: stringtail;
       k: Integer;
       j: 1..slength;
begin
    null := chr(0);
    StaticLength := limit-lo+1;
    ExtraChunks := (StaticLength-1) div slength;
    { -- Copy into String head }
    new(StringHead);
    with StringHead^ do begin
        LEN := StaticLength;
        REFS := 0;
        TAIL := nil;
        k := lo;
        { -- Copy string, null padding if necessary }
        for j := 1 to slength do
           if j > StaticLength
           then HEAD[j] := null
           else begin
            HEAD[j] := static[k];
            k := k+1
           end;
        { -- Allocate and link in any extra string chunks needed}
        for i := 1 to ExtraChunks do begin
           new(temp); temp^.REST := TAIL; TAIL := temp
        end;
        { -- Loop through copying string tail if required }
        temp := TAIL;
        CurrentLength := 0;
        while temp <> nil do begin
           with temp^ do begin
            CurrentLength := CurrentLength+slength;
                    { -- Copy string, null padding if necessary }
            for j := 1 to slength do
               if j+CurrentLength > StaticLength
               then MORE[j] := null
               else begin
                    MORE[j] := static[k];
                    k := k+1
                end
           end;
           temp := temp^.REST
        end{ -- while}
    end{ -- with};
    { -- Return the newly created dynamic string }
    mk := StringHead
end{ -- mk};
SHAR_EOF
fi # end of overwriting check
if test -f 'mkS.p'
then
    echo shar: will not over-write existing file "'mkS.p'"
else
cat << \SHAR_EOF > 'mkS.p'




# include "strings.h"

function mkS{(static: packed array[lo..hi:Integer]of Char):String};
{
* Converts a static Pascal string into a (dynamic) String.
}
begin
    mkS := mk(static, hi)
end{ -- mkS};
SHAR_EOF
fi # end of overwriting check
if test -f 'mkStaticS.p'
then
    echo shar: will not over-write existing file "'mkStaticS.p'"
else
cat << \SHAR_EOF > 'mkStaticS.p'




# include "strings.h"

procedure mkStaticS{(s: String; var p: packed array[lo..hi:Integer] of Char)};
{
* Converts a dynamic string into a static string.
* p is null padded if necessary.
* Info will be lost if lengthS(s) > hi-lo+1.
}
   var i: Integer; j: Nat1; lens: Nat0; ch,null: Char; sp: CharOfString;
begin
    j := 1; lens := lengthS(s);  null := chr(0);
    if lens <> 0 then
      first(sp, s);
    for i := lo to hi do
      if j <= lens then begin
        next(sp, ch);
        p[i] := ch;
        j := j+1
      end
      else
        p[i] := null
end{ -- mkStaticS};
SHAR_EOF
fi # end of overwriting check
if test -f 'neS.p'
then
    echo shar: will not over-write existing file "'neS.p'"
else
cat << \SHAR_EOF > 'neS.p'




# include "strings.h"

function neS{(left,right: String):Boolean};
{
* left <> right
}
begin
    neS := compare(left, right) <> eq
end{ -- neS};
SHAR_EOF
fi # end of overwriting check
if test -f 'newS.p'
then
    echo shar: will not over-write existing file "'newS.p'"
else
cat << \SHAR_EOF > 'newS.p'




# include "strings.h"

procedure newS{(var s: String)};
{
* Initialises s to be the empty or null string ''
}
begin
    s := nil
end{ -- newS};
SHAR_EOF
fi # end of overwriting check
if test -f 'next.p'
then
    echo shar: will not over-write existing file "'next.p'"
else
cat << \SHAR_EOF > 'next.p'




# include "strings.h"

procedure next{(var c: CharOfString; var ch: Char)};
{
* c is advanced to point to next char in its string and current char
* returned in ch
*
* precondition
*     c initialised by call to first and not at end of string
}
  var nxtchunk: stringtail;
begin
    with c do
     case KIND of
      true: begin { -- header record }
         ch := HD^.HEAD[POS];
         if POS <> slength then
            POS := POS+1
         else begin
            POS := 1;
            nxtchunk := HD^.TAIL;
            { -- change variant }
            KIND := false;
            TL := nxtchunk
         end
        end;
      false: begin { -- tail record }
          ch := TL^.MORE[POS];
          if POS <> slength then
            POS := POS+1
          else begin
            POS := 1;
            TL := TL^.REST
          end
         end
     end{ -- case}
end;
SHAR_EOF
fi # end of overwriting check
if test -f 'readS.p'
then
    echo shar: will not over-write existing file "'readS.p'"
else
cat << \SHAR_EOF > 'readS.p'




# include "strings.h"

procedure readS{(var f: Text; var s: String)};
{
* Reads a string from text file f; eoln terminating.  The input is
* left pointing to the beginning of the next line, if any.
*
* precondition:
*    f open for reading & not eof(f)
}
    const BufferLength = 120;
    var t : String;
        i : Nat0;
     line : packed array [1..BufferLength] of Char;

begin
    i := 0;
    while not eoln(f) and (i <> BufferLength) do begin
        i := i+1;
        read(f, line[i])
    end;
    if i = 0 then assignS(s, nil) else assignS(s, mk(line, i));
    { --  Check for more characters on the input line }
    if (i = BufferLength) and not eoln(f) then begin
        { --  Get the rest }
        t := nil;
        readS(f, t);
        assignS(s, concatS(s, t))
    end;
    if eoln(f) then get(f)
end{ -- readS};
SHAR_EOF
fi # end of overwriting check
if test -f 'readtS.p'
then
    echo shar: will not over-write existing file "'readtS.p'"
else
cat << \SHAR_EOF > 'readtS.p'




# include "strings.h"

procedure readtS{(var f: Text; var s: String; function stop(c:Char):Boolean)};
{
* Reads a string from text file f; eoln or stop(c) returning true
* (whichever occurs first) terminating.  In either case,
* input is left positioned at the terminator.
*
* precondition:
*    f open for reading & not eof(f)
}
    const BufferLength = 120;
    var t : String;
        i : Nat0;
     line : packed array [1..BufferLength] of Char;
begin
    i := 0;
    while not eoln(f) and (i <> BufferLength) and not stop(f^) do begin
        i := i+1;
        read(f, line[i])
    end;
    if i = 0 then assignS(s, nil) else assignS(s, mk(line, i));
    { --  Check for more characters on the input line }
    if (i = BufferLength) and not stop(f^) and not eoln(f) then begin
        { --  Get the rest }
        t := nil;
        readS(f, t);
        assignS(s, concatS(s, t))
    end
end{ -- readtS};
SHAR_EOF
fi # end of overwriting check
if test -f 'repS.p'
then
    echo shar: will not over-write existing file "'repS.p'"
else
cat << \SHAR_EOF > 'repS.p'




# include "strings.h"

function repS{(s: String; n: Nat0):String};
{
* [[ Returns s * n ]]
* Replicates s, n times.
}
  var  null, ChFromS: Char;
       lens, StaticLength: Nat0;
       i, ExtraChunks, CurrentLength: Nat0;
       StringHead: String;
       temp: stringtail;
       k: Integer;
       j: 1..slength;
       sp: CharOfString;
begin
  null := chr(0); lens := lengthS(s); StaticLength := lens*n;
  if StaticLength = 0 then repS := nil { -- emptyS} else begin
    ExtraChunks := (StaticLength-1) div slength;
    { -- Copy into String head }
    new(StringHead);
    with StringHead^ do begin
        LEN := StaticLength;
        REFS := 0;
        TAIL := nil;
        first(sp, s); k := 1;
        { -- Copy string, null padding if necessary }
        for j := 1 to slength do
           if j > StaticLength
           then HEAD[j] := null
           else begin
            next(sp, ChFromS);
            if k = lens then begin
            k := 1; first(sp, s)
            end else
            k := k+1;
            HEAD[j] := ChFromS
           end;
        { -- Allocate and link in any extra string chunks needed}
        for i := 1 to ExtraChunks do begin
           new(temp); temp^.REST := TAIL; TAIL := temp
        end;
        { -- Loop through copying string tail if required }
        temp := TAIL;
        CurrentLength := 0;
        while temp <> nil do begin
           with temp^ do begin
            CurrentLength := CurrentLength+slength;
                    { -- Copy string, null padding if necessary }
            for j := 1 to slength do
               if j+CurrentLength > StaticLength
               then MORE[j] := null
               else begin
                    next(sp, ChFromS);
                    if k = lens then begin
                        k := 1; first(sp, s)
                    end else
                        k := k+1;
                    MORE[j] := ChFromS
                end
           end;
           temp := temp^.REST
        end{ -- while};
        end{ -- with};
    { -- Return the newly created dynamic string }
    repS := StringHead
  end;
  if s <> nil then if s^.REFS = 0 then disposeS(s);
end{ -- repS};
SHAR_EOF
fi # end of overwriting check
if test -f 'updateS.p'
then
    echo shar: will not over-write existing file "'updateS.p'"
else
cat << \SHAR_EOF > 'updateS.p'




# include "strings.h"

procedure updateS{(var s: String; i: Nat1; c:Char)};
{
* Updates the string s at position  i  with the char c.
* if i > lengthS(s), s is first space filled upto i-1.
}
   var j: 2..maxint;
       chunk: stringtail;

  procedure copy(var lhs: String; rhs: String);
  {
  *  lhs := rhs (forces a string copy)
  }
    var ExtraChunks: Nat0; i: Nat1; temp, l, r: stringtail;
  begin
    new(lhs);
    { -- Copy string head }
    lhs^ := rhs^;
    with lhs^ do begin
      REFS := 1;
      ExtraChunks := (rhs^.LEN-1) div slength;
      TAIL := nil;
          { -- Allocate and link in any extra string chunks needed }
      for i := 1 to ExtraChunks do begin
        new(temp); temp^.REST := TAIL; TAIL := temp
       end
     end;
        { -- Loop through copying string tail if required }
     l := lhs^.TAIL;  r := rhs^.TAIL;
     for i := 1 to ExtraChunks do begin
        l^.MORE := r^.MORE;
        l := l^.REST;
        r := r^.REST
     end
  end{ -- copy};


begin { --  of updateS }
  if s <> nil then
     with s^ do
      if REFS > 1 then begin
    { -- Make a unique copy before update }
    REFS := REFS-1;
    copy(s, s) { --  N.B. careful (!) use of var and value params. }
      end;
  if i <= lengthS(s) then
    with s^ do
      if i <= slength
      then { -- pos is in string head } HEAD[i] := c
      else begin
        { -- find tail chunk containing pos. i }
        chunk := TAIL;
        for j := 2 to (i-1) div slength do
            chunk := chunk^.REST;
        chunk^.MORE[ (i-1) mod slength + 1 ]  := c
      end
  else { -- Inefficient but rare case }
    assignS(s, concatS(s,concatS(repS(CtoS(' '),i-lengthS(s)-1),CtoS(c))))
end{ -- updateS};
SHAR_EOF
fi # end of overwriting check
if test -f 'writeS.p'
then
    echo shar: will not over-write existing file "'writeS.p'"
else
cat << \SHAR_EOF > 'writeS.p'



# include "strings.h"

procedure writeS{var f: Text; s: String)};
{
* Write the dynamic string s to file f
*
* precondition:
*    f open for writing
}
   var temp: stringtail;
       i, Currentlength: Nat1; ExtraChunks: Nat0;
begin
    if s = nil then { -- Do nothing if string = '' }
    else begin
     with s^ do begin
        ExtraChunks := (LEN-1) div slength;
        if LEN > slength then
            CurrentLength := slength
        else
            CurrentLength := LEN;
        write(f, HEAD:CurrentLength);
        temp := TAIL;
        { -- Output any tail chunks }
        for i := 1 to ExtraChunks do with temp^ do
            if i <> ExtraChunks then begin
                write(f, MORE);
                temp := REST
            end else
                if LEN mod slength <> 0 then
                write(f, MORE:(LEN mod slength))
                else
                write(f, MORE)
     end;
     { -- may have been asked to output a constant string }
     if s^.REFS = 0 then disposeS(s)
    end
end{ -- writeS};


SHAR_EOF
fi # end of overwriting check
if test -f 'writelnS.p'
then
    echo shar: will not over-write existing file "'writelnS.p'"
else
cat << \SHAR_EOF > 'writelnS.p'




# include "strings.h"

procedure writelnS{(var f: Text; s: String)};
{
* Write the dynamic string s to file f followed by an eoln marker
*
* precondition:
*    f open for writing
}
begin
    writeS(f, s);
    writeln(f)
end{ -- writelnS};
SHAR_EOF
fi # end of overwriting check
if test -f 'Makefile'
then
    echo shar: will not over-write existing file "'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
PFLAGS=-O -L

OBJ= initvalparamS.o finalS.o initS.o mk.o mkS.o CtoS.o writeS.o emptyS.o lengthS.o writelnS.o assignS.o repS.o concatS.o disposeS.o readtS.o readS.o indexS.o getsubS.o mkStaticS.o matchS.o updateS.o compare.o eqS.o\
neS.o ltS.o \
first.o next.o gtS.o leS.o geS.o newS.o

strings.a: strings.h  ${OBJ}
    ar ruv strings.a ${OBJ}
    ranlib strings.a

${OBJ}: strings.h
SHAR_EOF
fi # end of overwriting check
#    End of shell archive
exit 0


----- End Forwarded Message -----